home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / shellMode.tcl < prev    next >
Encoding:
Text File  |  1997-12-08  |  13.5 KB  |  561 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  # 
  4.  #  FILE: "shellMode.tcl"
  5.  #                                last update: 8/12/97 {10:30:24 am} 
  6.  #  Author: Vince Darley, Pete Keleher
  7.  #  E-mail: <darley@fas.harvard.edu>
  8.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  9.  #          Oxford Street, Cambridge MA 02138, USA
  10.  #     www: <http://www.fas.harvard.edu/~darley/>
  11.  #  
  12.  # Some Copyright (c) 1997  Vince Darley
  13.  # Some copyright Pete Keleher.
  14.  # 
  15.  #  Description: 
  16.  # 
  17.  # General purpose shell routines for Alpha.  Two and a half shells
  18.  # are provided by default: the Alpha Tcl shell, the MPW toolserver
  19.  # shell and half of the comet shell (whatever that is).
  20.  # 
  21.  # A separate package 'remotetclshell' allows Alpha to act as a console
  22.  # for a separately running Wish.
  23.  # ###################################################################
  24.  ##
  25.  
  26. alpha::mode Shel 1.7.2 dummyShel {"*tcl\ sh*"} tclMenu {
  27.     regModeKeywords -m {«} Shel {}
  28.     addMode MPW {} {"*Toolserver\ *"} {}
  29.     # we use our own version since Alpha doesn't quite change mode
  30.     # to Shel correctly (not sure what it does wrong).
  31.     catch {rename shell {}}
  32.     # we do this ourselves.  this way we don't need a special hack
  33.     # in 'openHook'
  34.     catch {rename toolserverShell {}}
  35. }
  36.  
  37. newPref v wordBreak {(\$)?[a-zA-Z0-9_.]+} Shel
  38. newPref f wordWrap {0} Shel
  39. newPref v wordBreakPreface {[^a-zA-Z0-9_\$]} Shel
  40. newPref f autoMark 0 Shel
  41. newPref f tcl_interactive 1 Shel
  42. set invisibleModeVars(tcl_interactive) 1
  43. set Shel::endPara {^«.*$}
  44. set Shel::startPara {^«.*$}
  45. ensureset Shel::histnum 0
  46.  
  47. bind '\r' Shel::carriageReturn "Shel"
  48. bind '\r' Shel::carriageReturn "MPW"
  49. bind '\t' bind::Completion Shel
  50.  
  51. bind up <z> Shel::prevHist Shel
  52. bind down <z> Shel::nextHist Shel
  53.  
  54. bind 'a' <z> Shel::Bol Shel
  55. bind up Shel::up Shel
  56. bind down Shel::down Shel
  57.  
  58. bind 'u' <z> Shel::killLine Shel
  59.  
  60. proc dummyShel {} {}
  61.  
  62. ensureset otherDirs {}
  63.  
  64. proc Shel::OptionTitlebar {} {
  65.     regsub -all "\n *" [history] "\} \{" h
  66.     set h "\{[string trim $h]\}"
  67. }
  68.  
  69. proc Shel::OptionTitlebarSelect {item} {
  70.     insertText [string range $item [expr 2+[string first " " $item]] end]
  71.     Shel::carriageReturn
  72. }
  73.  
  74. proc Shel::DblClick {args} { eval Tcl::DblClick $args }
  75.  
  76. ## 
  77.  # -------------------------------------------------------------------------
  78.  # 
  79.  # "Shel::carriageReturn" --
  80.  # 
  81.  #  Rewritten to avoid need for global _text _return variables
  82.  # -------------------------------------------------------------------------
  83.  ##
  84. proc Shel::carriageReturn {} {
  85.     global mode histnum Shel::Type
  86.     set pos [getPos]
  87.  
  88.     if {![catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] && $res} {
  89.         gotoMatch; return;
  90.     }
  91.     set ind [string first "»" [getText [lineStart $pos] $pos]]
  92.     if {$ind < 0} {
  93.         insertText "\r"
  94.         return
  95.     }
  96.     endOfLine
  97.     set fileName [win::CurrentTail]
  98.     set type [set Shel::Type($fileName)]
  99.     # sort out where we're going to put the answer
  100.     set t [getText [expr [lineStart $pos]+$ind+2] [getPos]]
  101.     if {[getPos] != [maxPos]} {
  102.         goto [set pos [maxPos]]
  103.         set ind [string first "»" [getText [lineStart $pos] $pos]]
  104.         if {$ind < 0} {
  105.             insertText "\r" [${type}::Prompt]
  106.         } else {
  107.             incr ind [expr 2 + [lineStart $pos]]
  108.             if {$ind != $pos} {
  109.                 deleteText $ind $pos
  110.             }
  111.         }
  112.         insertText -w $fileName $t
  113.     }
  114.     # carry out the action
  115.     set r [${type}::eval $t]
  116.     insertText -w $fileName "\r" $r 
  117.     if {$r != ""} { 
  118.         insertText -w $fileName "\r"
  119.     }
  120.     insertText -w $fileName [${type}::Prompt]
  121. }
  122.  
  123. proc Shel::start {type {title ""} {startuptext ""}} {
  124.     if {$title != ""} {
  125.         if ![catch {bringToFront $title}] {
  126.             return
  127.         }
  128.         new -n $title -m Shel
  129.         setWinInfo shell 1
  130.         if {$startuptext != ""} {
  131.             insertText $startuptext
  132.         }
  133.     }
  134.     global Shel::Type
  135.     set c [win::Current]
  136.     set Shel::Type($c) $type
  137.     insertText -w $c [${type}::Prompt]
  138. }
  139.  
  140. # ◊◊◊◊ Alpha shell routines ◊◊◊◊ #
  141.  
  142. proc tclLog {string} {
  143.     catch {insertText -w "*tcl shell*" "\r" $string}
  144. }
  145.  
  146. proc shell {} {
  147.     Shel::start "Alpha" "*tcl shell*" "Welcome to Alpha's Tcl shell.\r"
  148. }
  149.  
  150. namespace eval Alpha {}
  151.  
  152. proc Alpha::eval {t} {
  153.     global errorInfo Shel::histnum
  154.     history add $t
  155.     if {[set code [catch {uplevel \#0 $t} msg]] == 1} {
  156.         # strip off end of error due to 'uplevel' command
  157.         set new [split $errorInfo \n]
  158.         set new [join [lrange $new 0 [expr [llength $new] - 4]] \n]
  159.         set errorInfo "$new"
  160.         set msg "Error: $msg"
  161.     }
  162.     set Shel::histnum [history nextid]
  163.     return $msg
  164. }
  165. proc Alpha::Prompt {} {
  166.     return "«[file tail [string trimright [pwd] {:}]]» "
  167. }
  168.  
  169. # ◊◊◊◊ MPW routines ◊◊◊◊ #
  170. namespace eval mpw {}
  171. proc mpw::eval {t} {
  172.     catch {dosc -n ToolServer -s $t} r
  173.     return $r
  174. }
  175. proc mpw::Prompt {} { return "«mpw» " }
  176. proc toolserverShell {} {
  177.     Shel::start "mpw" {*Toolserver shell*} \
  178.       "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents).\r"
  179.     if [catch {app::ensureRunning ToolServer MPSX}] {
  180.         killWindow
  181.     }
  182. }
  183.  
  184. # ◊◊◊◊ Comet routines ◊◊◊◊ #
  185. namespace eval comet {}
  186. proc comet::eval {t} {
  187.     cometSendAndPrompt $t
  188.     return ""
  189. }
  190. proc comet::Prompt {} {}
  191.  
  192. # ◊◊◊◊ General purpose ◊◊◊◊ #
  193.  
  194. proc Shel::prevHist {} {
  195.     global Shel::histnum Shel::curCmdLine
  196.     
  197.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  198.     if {[set ind [string first "» " $text]] > 0} {
  199.         goto [expr [lineStart [getPos]] + $ind + 2]
  200.     } else return
  201.  
  202.     incr Shel::histnum -1
  203.     if {[catch {history event ${Shel::histnum}} text]} {
  204.         incr Shel::histnum
  205.         endOfLine
  206.         beep
  207.         return
  208.     }
  209.     set to [nextLineStart [getPos]]
  210.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  211.     if { [expr ${Shel::histnum} + 1] == [history nextid] } {
  212.         set Shel::curCmdLine [getText [getPos] $to]
  213.     }
  214.     replaceText [getPos] $to $text
  215. }
  216.  
  217.  
  218. proc Shel::nextHist {} {
  219.     global Shel::histnum Shel::curCmdLine
  220.   
  221.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  222.     if {[set ind [string first "» " $text]] > 0} {
  223.         goto [expr [lineStart [getPos]] + $ind + 2]
  224.     } else return
  225.  
  226.     if {${Shel::histnum} == [history nextid]} {
  227.         beep
  228.         endOfLine
  229.         return
  230.     }
  231.     
  232.     incr Shel::histnum
  233.     if {${Shel::histnum} == [history nextid]} {
  234.         set text ${Shel::curCmdLine}
  235.     } else {
  236.         if {[catch {history event ${Shel::histnum}} text]} {
  237.             endOfLine
  238.             return
  239.         }
  240.     }
  241.     set to [nextLineStart [getPos]]
  242.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  243.     replaceText [getPos] $to $text
  244. }
  245.  
  246. proc Shel::killLine {} {
  247.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  248.     if {[set ind [string first "» " $text]] > 0} {
  249.         goto [expr [lineStart [getPos]] + $ind + 2]
  250.     } else {
  251.         return
  252.     }
  253.     set to [nextLineStart [getPos]]
  254.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  255.     deleteText [getPos] $to
  256. }
  257.  
  258. proc Shel::Bol {} {
  259.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  260.     if {[set ind [string first "» " $text]] > 0} {
  261.         goto [expr [lineStart [getPos]] + $ind + 2]
  262.     } else {
  263.         goto [lineStart [getPos]]
  264.     }
  265. }
  266.  
  267. proc Shel::up {} {
  268.     set pos [expr [lineStart [getPos]] - 1]
  269.     if {[catch {regexp {∞} [getText [lineStart $pos] [nextLineStart $pos]]} res] || !$res} {
  270.         previousLine; return
  271.     }
  272.     select [lineStart $pos] [nextLineStart $pos]
  273. }
  274.  
  275. proc Shel::down {} {
  276.     set pos [nextLineStart [getPos]]
  277.     if {[catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] || !$res} {
  278.         nextLine; return
  279.     }
  280.     select $pos [nextLineStart $pos]
  281. }
  282.  
  283. # ◊◊◊◊ Unix imitation ◊◊◊◊ #
  284.  
  285. proc l {args} {
  286.     eval [concat "ls -CF" $args]}
  287.  
  288. proc ll {args} {
  289.     eval [concat "ls -l" $args]}
  290.  
  291.  
  292. proc wc {args} {
  293.     set res {}
  294.     set totChars 0
  295.     set totLines 0
  296.     set totWords 0
  297.     set args [glob -nocomplain $args]
  298.     foreach file $args {
  299.         set id [open $file]
  300.         set chars [string length [set text [read $id]]]
  301.         set lines [llength [split $text "\n"]]
  302.         set words [llength [split $text]]
  303.         append res [format "\r%8d%8d%8d    $file" $lines $words $chars]
  304.         set totChars [expr $totChars+$chars]
  305.         set totWords [expr $totWords+$words]
  306.         set totLines [expr $totLines+$lines]
  307.         close $id
  308.     }
  309.     if {[llength $args] > 1} {
  310.         append res [format "\r%8d%8d%8d    total" $totLines $totWords $totChars]
  311.     }
  312.     return [string range $res 1 end]
  313. }
  314.  
  315.  
  316.  
  317. #================================================================================
  318. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  319. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  320. # assumed to be the parent directory of the top directory we are creating.
  321. #================================================================================
  322. proc cpdir {from to} {
  323.     set cwd [pwd]
  324.     if {[string match ":*" $from] || [string match ":*" $to] ||
  325.         ![file exists $from] || ![file exists $to]} {
  326.         error "'cpdir' args must be complete pathnames of existing folders."
  327.     }
  328.     if {![string match "*:" $from]} {append from ":"}
  329.     if {![string match "*:" $to]} {append to ":"}
  330.     
  331.     if {![file isdir $from] || ![file isdir $to]} {
  332.         exit 1
  333.     }
  334.         
  335.     set res [catch {cphier $from $to} val]
  336.     cd $cwd
  337.     if {$res} {error $val}
  338. }
  339.  
  340. proc cphier {from to} {
  341.     set savedir [pwd]
  342.     if {[string index $from [expr [string len $from] - 1]] != ":"} {append from ":"}
  343.     set dir [file tail [string trimright $from ":"]]
  344.     cd $to
  345.     mkdir "$dir"
  346.     foreach f [glob "$from*"] {
  347.         if {[file isdir $f]} {
  348.             cphier "$f:" "$to$dir:"
  349.         } else {
  350.             cp $f $to$dir:
  351.         }
  352.     }
  353.     cd $savedir
  354. }
  355.  
  356.         
  357. #================================================================================
  358. #####
  359. # (Usage:  'lt' sorts by time, like UNIX's 'ls -lt'.
  360. #          'lt -t' sorts by filename, like UNIX's 'ls -l'.
  361. #          Optionally a directory name can be added as an argument.)
  362.  
  363. proc sortdt {dt} {
  364.     scan $dt "%d/%d/%d {%d:%d:%d %1sM}" mon day yea hou min sec z
  365.     if {$z == "P"} {incr hou 12}
  366.     if {[string length $yea] == 1} {
  367.         set year 200$yea
  368.     } elseif {$yea > 40} {
  369.         set year 19$yea
  370.     } else {
  371.         set year 20$yea
  372.     }
  373.     return [format "%04d%02d%02d%02d%02d" $year $mon $day $hou $min]
  374. }
  375.  
  376.  
  377. proc lth args {
  378.     global mode
  379.     
  380.     set val "*"
  381.     set sort 1
  382.     scan [lindex [mtime [now]] 0] "%d/%d/%d" one two three
  383.     if {[string length $three] == 1} {
  384.         set year 200$three
  385.     } elseif {$three > 40} {
  386.         set year 19$three
  387.     } else {
  388.         set year 20$three
  389.     }
  390.     
  391.     foreach arg $args {
  392.         switch -- $arg {
  393.             "-t"    {set sort 0}
  394.             default {set val $arg}
  395.         }
  396.     }
  397.     set mod ""
  398.     foreach f [eval glob $val] {
  399.         if {[catch {getFileInfo $f info}]} {
  400.             if {$sort} {set mod "000000000000 "}
  401.             lappend text [format "%s%s %8d%8d %6s %5s %4s %s %s\n" $mod "D" "0" "0" "" "" "" "DIR " [file tail $f]]
  402.             continue
  403.         }
  404.         if {$sort} {set mod "[sortdt [mtime $info(modified) s]] "}
  405.         set m [mtime $info(modified) a]
  406.         set zer [lindex $m 0]
  407.         set dat [format "%s %2s" [lindex $zer 1] [string trimright [lindex $zer 2] {,}]]
  408.         if {[lindex $zer 3] == $year} {
  409.             if {[scan [lindex $m 1] "%d:%d:%d %s" one two three am] != 4} {
  410.                 error "Didn't get four from scan"
  411.             }
  412.             if {[string length $two] == 1} {set two "0$two"}
  413.             set tm [expr {$am == "AM"} ? $one : [expr $one + 12]]:$two
  414.         } else {
  415.             set tm " [lindex $zer 3]"
  416.         }
  417.         lappend text [format "%sF %8d%8d %s %5s %s %s %s\n" $mod $info(datalen) $info(resourcelen) $dat $tm $info(type) $info(creator) [file tail $f]]
  418.     }
  419.     if {$sort} {
  420.         foreach ln [lsort -de $text] {
  421.             append txt [string range $ln 13 end]
  422.         }
  423.         set ans [string trimright $txt]
  424.     } else {
  425.         set ans [string trimright [join $text {}]]
  426.     }
  427.     
  428.     if { $mode=="Shel" } { return $ans } else {
  429.         new
  430.         insertText $ans "\r"
  431.         catch shrinkHeight
  432.         setWinInfo dirty 0
  433.         setWinInfo read-only 1
  434.     }
  435. }
  436.  
  437. #================================================================================
  438. proc ps {} {
  439.     foreach p [processes] {
  440.         append text [format "%-25s %4s %10d %10d\r" [lindex $p 0] [lindex $p 1] [lindex $p 2] [lindex $p 3]]
  441.     }
  442.     return [string trimright $text]
  443. }
  444.  
  445.  
  446. #================================================================================
  447. # Recursively make creator of all text files 'ALFA'. Optionally takes a starting
  448. # dir argument, otherwise starts in current directory. Auto-Doubled are no 
  449. # longer recognized by auto-doubler! Why? Some sort of conflict w/ 'PBSetFInfo'.
  450. proc creator {{dir ":"}}  {
  451.     if {![catch {glob -t TEXT $dir*} files]} {
  452.         foreach f $files {
  453.             message $f
  454.             setFileInfo $f creator ALFA
  455.         }
  456.     }
  457.     
  458.     if {![catch {glob $dir*} dirs]} {
  459.         foreach d $dirs {
  460.             if {[file isdir $d]} {creator $d:}
  461.         }
  462.     }
  463. }
  464.  
  465.  
  466. #===============================================================================
  467.  
  468. proc tomac args {
  469.     set files {}
  470.     foreach arg $args {
  471.         append files " " [glob $arg]
  472.     }
  473.     set dir [pwd]
  474.     
  475.     foreach f $files {
  476.         message "$f..."
  477.         set fd [open $dir$f "r"]
  478.         set text [read $fd]
  479.         close $fd
  480.         regsub -all "\n" $text "\r" text
  481.         
  482.         set fd [open "$dir$f" "w"]
  483.         puts -nonewline $fd $text
  484.         close $fd
  485.     }
  486.     message ""
  487. }
  488.  
  489.  
  490. #===============================================================================
  491.  
  492. proc unixToMac {fname} {
  493.     set fd [open $fname]
  494.     set text [read $fd]
  495.     close $fd
  496.     set fd [open $fname "w"]
  497.     puts -nonewline $fd $text
  498.     close $fd
  499. }
  500.  
  501. proc setCreator args {
  502.     set files {}
  503.     set creator [car $args]
  504.     foreach arg [cdr $args] {
  505.         append files " " [glob $arg]
  506.     }
  507.     
  508.     foreach f $files {
  509.         setFileInfo $f creator $creator
  510.     }
  511. }
  512.  
  513. proc setType args {
  514.     set files {}
  515.     set type [car $args]
  516.     foreach arg [cdr $args] {
  517.         append files " " [glob $arg]
  518.     }
  519.     
  520.     foreach f $files {
  521.         setFileInfo $f type $type
  522.     }
  523. }
  524. #===============================================================================
  525.  
  526. proc pushd {args} {
  527.     global otherDirs
  528.     if {[string length $args]} {
  529.         set otherDirs [cons [pwd] $otherDirs]
  530.         cd [string trim [eval list $args] "        \{\}"]
  531.     } else {
  532.         if {[llength $otherDirs]} {
  533.             set n [car $otherDirs]
  534.             set otherDirs [cons [pwd] [cdr $otherDirs]]
  535.             cd $n
  536.         } else {
  537.             return "No other directories"
  538.         }
  539.     }
  540. }
  541. proc pd {args} {
  542.     if {[string length $args]} {
  543.         eval pushd $args
  544.     } else {
  545.         pushd
  546.     }
  547. }
  548.  
  549.  
  550. proc dirs {} {global otherDirs; cons [pwd] $otherDirs}
  551.  
  552. proc popd {} {
  553.     global otherDirs
  554.     if {[llength $otherDirs]} {
  555.         cd [car $otherDirs]
  556.         set otherDirs [cdr $otherDirs]
  557.     } else {
  558.         return "No other directories"
  559.     }
  560. }
  561.